{-# OPTIONS -XMultiParamTypeClasses #-}
module Fits where

import qualified Data.ByteString.Lazy as B
import Data.ByteString.Internal (c2w)
import Data.Int

type Header = [Record]
type Comment = String

data Record = Record Keyword Value Comment | END

instance Show Record where
    show END = "END"
    show (Record (Keyword k) v c) = k ++ " = " ++ show v

data Keyword = Keyword String deriving (Show)

data Value = VInt Int | VFloat Float | VString String | VBool Bool 

instance Show Value where
    show (VInt    v) = show v
    show (VFloat  v) = show v
    show (VString v) = v
    show (VBool   v) = case v of
                        True  -> "T"
                        False -> "F"

data HDU = HDUImage Header B.ByteString

instance Show HDU where
    show (HDUImage h _) = join "\n" $ map (show) h

class FitsImage i where
    serializeImage :: i -> IO HDU

s2s :: String -> B.ByteString
s2s = B.pack . map (c2w)

join :: String -> [String] -> String
join s = foldr1 (\a b -> a ++ s ++ b)

round2880 :: B.ByteString -> B.ByteString
round2880 s = paddingL s bytes where
    r = n `mod` 2880
    bytes = if r == 0 then n else 2880 + n - r
    n = B.length s

serializeHeader :: Header -> B.ByteString
serializeHeader h = round2880 raw where
    raw = B.concat $ map (serializeRecord) h

serializeRecord :: Record -> B.ByteString
serializeRecord END = paddingL (s2s "END") 80
serializeRecord (Record (Keyword s) v c) = paddingL record 80 where
    record = (paddingL keyword 8) `B.append` (s2s "= ") `B.append` value `B.append` comment
    keyword = s2s s
    value   = s2s $ show v
    comment = s2s (if null c then [] else " / " ++ c)

paddingL :: B.ByteString -> Int64 -> B.ByteString
paddingL a l | len > l = error "length string bigger than l"
             | len == l = a
             | otherwise = a `B.append` (B.take (l - len) b) 
  where
    len = B.length a
    b = B.repeat 0x20

writeFits :: FilePath -> HDU -> IO ()
writeFits file (HDUImage header raw) = B.writeFile file (serializeHeader header `B.append` raw)
